home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / emanip.lisp < prev    next >
Text File  |  1993-07-17  |  25KB  |  749 lines
  1. ;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base:10.; Fonts:CPTFONT -*-
  2.  
  3. ;;; (C) Copyright 1985 Massachusetts Institute of Technology
  4. ;;;
  5. ;;; Permission to use, copy, modify, distribute, and sell this software
  6. ;;; and its documentation for any purpose is hereby granted without fee,
  7. ;;; provided that the above copyright notice appear in all copies and that
  8. ;;; both that copyright notice and this permission notice appear in
  9. ;;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;;; advertising or publicity pertaining to distribution of the software
  11. ;;; without specific, written prior permission.  M.I.T. makes no
  12. ;;; representations about the suitability of this software for any
  13. ;;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;;
  15.  
  16. ;;;;Primitive box manipulation.
  17.  
  18. ;;This file defines the interface to the internal boxer data structure.
  19. ;;The functions in this file should be use as an interface between the
  20. ;;internal editor data structure and the world.
  21.  
  22. ;;;; LABEL-PAIRs, NAME-PAIRs, and the concept of ROW-ENTRIES
  23.  
  24. (DEFCONST *INPUTS-CODE* #/)
  25. (DEFCONST *LABELLING-CODE* #/:)
  26. (defconst *accessing-code* #/)
  27.  
  28. ;;; excls and atsigns
  29.  
  30. (DEFVAR *UNBOX-MARKER* 'UNBOX-IT)
  31. (DEFVAR *EVAL-MARKER* 'EVAL-IT)
  32.  
  33. (DEFUN MAKE-LABEL-PAIR (LABEL ELEMENT)
  34.   `(:LABEL-PAIR ,LABEL . ,ELEMENT))
  35.  
  36. (DEFSUBST LABEL-PAIR? (X)
  37.   (AND (LISTP X)
  38.        (EQ (CAR X) ':LABEL-PAIR)))
  39.  
  40. (DEFSUBST LABEL-PAIR-LABEL (LABEL-PAIR)
  41.   (CADR LABEL-PAIR))
  42.  
  43. (DEFSUBST LABEL-PAIR-ELEMENT (LABEL-PAIR)
  44.   (CDDR LABEL-PAIR))
  45.  
  46. (DEFPROP :LABEL-PAIR MAKE-LABEL-PAIR-STREAM :MAKE-BOXER-STREAM)
  47.  
  48. (DEFUN MAKE-LABEL-PAIR-STREAM (LABEL-PAIR)
  49.   (MAKE-PDL-STREAM `(,(FORMAT NIL "~A" (LABEL-PAIR-LABEL LABEL-PAIR))
  50.              ,*LABELLING-CODE*
  51.              ,(IF (EQ :NO-ELEMENT (LABEL-PAIR-ELEMENT LABEL-PAIR))
  52.               ""
  53.               (FORMAT NIL "~A" (LABEL-PAIR-ELEMENT LABEL-PAIR))))))
  54.  
  55. ;;; Atsigns at top level and inside of builds
  56.  
  57. (DEFUN MAKE-UNBOX-TOKEN (UNBOX-TYPE BOX)
  58.   (LIST UNBOX-TYPE BOX))
  59.  
  60. (DEFSUBST UNBOX-TOKEN? (X)
  61.   (AND (LISTP X)
  62.        (EQ (CAR X) *UNBOX-MARKER*)))
  63.  
  64. (DEFSUBST UNBOX-TOKEN-TYPE (UNBOX-TOKEN)
  65.   (CAR UNBOX-TOKEN))
  66.  
  67. (DEFSUBST UNBOX-TOKEN-ELEMENT (UNBOX-TOKEN)
  68.   (CADR UNBOX-TOKEN))
  69.  
  70. (PUTPROP *UNBOX-MARKER* 'MAKE-UNBOX-TOKEN-STREAM :MAKE-BOXER-STREAM)
  71.  
  72. (DEFUN MAKE-UNBOX-TOKEN-STREAM (UT)
  73.   (MAKE-PDL-STREAM `(@ ,(IF (BOX? (UNBOX-TOKEN-ELEMENT UT))
  74.                 (MAKE-BOX-STREAM (UNBOX-TOKEN-ELEMENT UT))
  75.                 (FORMAT NIL "~A" (UNBOX-TOKEN-ELEMENT UT))))))
  76.  
  77. ;;; Excls inside of BUILDs
  78.  
  79. (DEFUN MAKE-EVAL-IT-TOKEN (THING)
  80.   (LIST *EVAL-MARKER* THING))
  81.  
  82. (DEFSUBST EVAL-IT-TOKEN? (X)
  83.   (AND (LISTP X)
  84.        (EQ (CAR X) *EVAL-MARKER*)))
  85.  
  86. (DEFSUBST EVAL-IT-TOKEN-ELEMENT (ET)
  87.   (CADR ET))
  88.  
  89. (PUTPROP *EVAL-MARKER* 'MAKE-EVAL-IT-TOKEN-STREAM :MAKE-BOXER-STREAM)
  90.  
  91. (DEFUN MAKE-EVAL-IT-TOKEN-STREAM (ET)
  92.   (MAKE-PDL-STREAM `(! ,(IF (BOX? (EVAL-IT-TOKEN-ELEMENT ET))
  93.                 (MAKE-BOX-STREAM (EVAL-IT-TOKEN-ELEMENT ET))
  94.                 (FORMAT NIL "~A" (EVAL-IT-TOKEN-ELEMENT ET))))))
  95.  
  96.  
  97. (defun make-access-pair (superbox subbox)
  98.   `(:access-pair ,superbox . ,subbox))
  99.  
  100. (defsubst access-pair? (x)
  101.   (and (listp x)(eq (car x) ':access-pair)))
  102.  
  103. (defsubst access-pair-superbox (access-pair)(cadr access-pair))
  104. (defsubst access-pair-subbox (access-pair)(cddr access-pair))
  105.  
  106. (defprop :access-pair make-access-pair-stream :make-boxer-stream)
  107. (defun make-access-pair-stream (access-pair)
  108.   (make-pdl-stream `('(format nil "~A" (access-pair-superbox access-pair))
  109.              '*accessing-code*
  110.              ,(format nil "~A" (access-pair-subbox access-pair)))))
  111.  
  112. (DEFUN ROW-ENTRY? (X)
  113.   (OR (SYMBOLP X)
  114.       ;(NAME-PAIR? X)
  115.       (LABEL-PAIR? X)))
  116.  
  117. (DEFUN ROW-ENTRY-ELEMENT (ENTRY)
  118.   (COND ((LABEL-PAIR? ENTRY) (LABEL-PAIR-ELEMENT ENTRY))
  119.     ;((NAME-PAIR? ENTRY) (NAME-PAIR-ELEMENT ENTRY))
  120.     (T ENTRY)))
  121.  
  122. (DEFUN ROW-ENTRY-LABEL (ENTRY)
  123.   (COND ((LABEL-PAIR? ENTRY) (LABEL-PAIR-LABEL ENTRY))
  124.     (T ':NO-LABEL)))
  125.  
  126. ;(DEFUN ROW-ENTRY-NAME (ENTRY)
  127. ;  (COND ((NAME-PAIR? ENTRY) (NAME-PAIR-NAME ENTRY))
  128. ;    (T ':NO-NAME)))
  129.  
  130.  
  131.  
  132. (EVAL-WHEN (LOAD)
  133.   
  134. #-LMITI
  135. (SET-SYNTAX-FROM-CHAR *STRT-ROW-CODE* #/( *BOXER-READTABLE*)
  136. #-LMITI
  137. (SET-SYNTAX-FROM-CHAR *STOP-ROW-CODE* #/) *BOXER-READTABLE*)
  138.  
  139. #+LMITI
  140. (MULTIPLE-VALUE-BIND (FUN TERM-P)
  141.     (GET-MACRO-CHARACTER #/()
  142.   (SET-MACRO-CHARACTER *STRT-ROW-CODE* FUN TERM-P *BOXER-READTABLE*))
  143.  
  144. #+LMITI
  145. (MULTIPLE-VALUE-BIND (FUN TERM-P)
  146.     (GET-MACRO-CHARACTER #/))
  147.   (SET-MACRO-CHARACTER *STOP-ROW-CODE* FUN TERM-P *BOXER-READTABLE*))
  148.  
  149. (SET-SYNTAX-FROM-DESCRIPTION *QUOTE-CODE* 'SI:SLASH *BOXER-READTABLE*)
  150.  
  151. (SET-SYNTAX-MACRO-CHAR *STRT-BOX-CODE*
  152.                'BOXER-STRT-BOX-READER-MACRO
  153.                *BOXER-READTABLE*)
  154. (SET-SYNTAX-MACRO-CHAR *STOP-BOX-CODE*
  155.                'BOXER-STOP-BOX-READER-MACRO
  156.                *BOXER-READTABLE*)
  157.  
  158.  
  159. (SET-SYNTAX-MACRO-CHAR *INPUTS-CODE*
  160.                'BOXER-INPUTS-CHA-READER-MACRO
  161.                *BOXER-READTABLE*)
  162.  
  163. (SET-SYNTAX-MACRO-CHAR *LABELLING-CODE*
  164.                'BOXER-LABELLING-CHA-READER-MACRO
  165.                *BOXER-READTABLE*)
  166.  
  167. (set-syntax-macro-char *accessing-code*
  168.                'boxer-access-cha-reader-macro
  169.                *boxer-readtable*)
  170.  
  171. (set-syntax-macro-char #\space
  172.                'boxer-EV-row-whitespace-macro
  173.                *boxer-readtable*)
  174.  
  175. (SET-SYNTAX-MACRO-CHAR #/@
  176.                'BOXER-READER-UNBOX-MACRO
  177.                *BOXER-READTABLE*)
  178.  
  179. (SET-SYNTAX-MACRO-CHAR #/!
  180.                'BOXER-READER-EVAL-MACRO
  181.                *BOXER-READTABLE*)
  182. ;PEOPLE comments.
  183. (SET-SYNTAX-MACRO-CHAR #/;
  184.                'BOXER-COMMENT-CHA-READER-MACRO
  185.                *BOXER-READTABLE*)
  186.                
  187. ;Returned values.
  188. (SET-SYNTAX-MACRO-CHAR #/|
  189.                'BOXER-RETURNED-VALUE-CHA-READER-MACRO
  190.                *BOXER-READTABLE*)
  191.  
  192.  
  193. (SET-SYNTAX-FROM-DESCRIPTION #/` 'SI:ALPHABETIC *BOXER-READTABLE*)
  194. (SET-SYNTAX-FROM-DESCRIPTION #/, 'SI:ALPHABETIC *BOXER-READTABLE*)
  195. ;(SET-SYNTAX-FROM-DESCRIPTION #/( 'SI:ALPHABETIC *BOXER-READTABLE*)
  196. ;(SET-SYNTAX-FROM-DESCRIPTION #/) 'SI:ALPHABETIC *BOXER-READTABLE*)
  197. (SET-SYNTAX-FROM-DESCRIPTION #/# 'SI:ALPHABETIC *BOXER-READTABLE*)
  198. (SET-SYNTAX-FROM-DESCRIPTION #// 'SI:ALPHABETIC *BOXER-READTABLE*)
  199. (SET-SYNTAX-FROM-DESCRIPTION #/' 'SI:ALPHABETIC *BOXER-READTABLE*)
  200.  
  201. ;Screws floating point, but what the hell.  Otherwise we have to
  202. ;avoid "." between delimiters.  Currently, we use the GJC fix
  203. ;of looking at the atoms and seeing if they LOOK like flonums...
  204. (SET-SYNTAX-FROM-DESCRIPTION #/. 'SI:ALPHABETIC *BOXER-READTABLE*)
  205.  
  206. )
  207.  
  208.  
  209. (defun get-sensible-last-thing-from (list-so-far)
  210.   (cond ((eq list-so-far ':toplevel) (ferror "You need a name for this object!"))
  211.     ((null list-so-far) '(()))
  212.     (t (let ((last-thing (last list-so-far)))
  213.          (if (spaces? (car last-thing))
  214.          (get-sensible-last-thing-from (nbutlast list-so-far))
  215.               last-thing)))))
  216.  
  217. ;; note: we can't convert single element boxes with numbers to numbers here because of CHANGE
  218. (DEFUN BOXER-STRT-BOX-READER-MACRO (IGNORE STREAM)
  219.   (VALUES (FUNCALL STREAM ':TYI-A-BOX) NIL NIL))
  220.  
  221. (DEFUN BOXER-STOP-BOX-READER-MACRO (IGNORE IGNORE)
  222.   (FERROR "Boxer-Stream out of synch, Boxer-Read should never see a *Stop-Box-Code*"))
  223.  
  224. (DEFUN BOXER-LABELLING-CHA-READER-MACRO (LIST-SO-FAR STREAM)
  225.   (LET ((NEXT-NONBLANK-CHAR (TYIPEEK T STREAM *STOP-ROW-CODE*)))
  226.     (IF (EQ LIST-SO-FAR ':TOPLEVEL)
  227.     (VALUES (NCONS (MAKE-LABEL-PAIR NIL
  228.                     (IF (= NEXT-NONBLANK-CHAR *STOP-ROW-CODE*)
  229.                         ':NO-ELEMENT
  230.                         (READ STREAM ':NO-ELEMENT))))
  231.         NIL T)
  232.     (LET* ((LAST (get-sensible-last-thing-from list-so-far))
  233.            (LAST-ELEMENT (CAR LAST)))
  234.       (RPLACA LAST (MAKE-LABEL-PAIR LAST-ELEMENT
  235.                     (IF (= NEXT-NONBLANK-CHAR *STOP-ROW-CODE*)
  236.                         ':NO-ELEMENT
  237.                         (READ STREAM ':NO-ELEMENT))))
  238.       (VALUES LIST-SO-FAR NIL T)))))
  239.  
  240. (DEFUN BOXER-INPUTS-CHA-READER-MACRO (LIST-SO-FAR IGNORE)
  241.   (VALUES (APPEND LIST-SO-FAR (NCONS 'BU:INPUTS)) NIL T))
  242.  
  243. (defun boxer-access-cha-reader-macro (list-so-far stream)
  244.   (let* ((last (get-sensible-last-thing-from list-so-far))(last-element (car last))
  245.      (next-nonblank-char (tyipeek t stream *stop-row-code*)))
  246.     (if (not (numberp last-element))
  247.     (rplaca last (make-access-pair last-element (if (= next-nonblank-char *stop-row-code*)
  248.                             ':no-element
  249.                             (read stream ':no-element))))
  250.     (rplaca last (+ last-element 
  251.             (if (= next-nonblank-char *stop-row-code*) 0.
  252.                 (let ((no (read stream ':no-element)))
  253.                   (if (zerop no) 0.
  254.                   (* no
  255.                      (// 1.0 (expt 10
  256.                            (1+ (fix  (// (log no) (log 10)))))))))))))
  257.                                 
  258.                               
  259.     (values list-so-far nil t)))
  260.  
  261. (DEFUN BOXER-EV-ROW-WHITESPACE-MACRO (LIST-SO-FAR STREAM)
  262.   STREAM ; the variable was bound but never used...
  263.   (COND    ((EQ LIST-SO-FAR ':TOPLEVEL)(VALUES LIST-SO-FAR NIL T))
  264.     (T (LET ((LAST-EL (CAR (LAST LIST-SO-FAR)))(RESULT))
  265.          (COND ((SPACES? LAST-EL)(RPLACD LAST-EL (1+ (GET-SPACES LAST-EL)))
  266.             (VALUES LIST-SO-FAR NIL T))
  267.            (T (SETQ RESULT (NCONC LIST-SO-FAR (LIST (CONS *SPACING-INFO-SYMBOL* 1))))
  268.               (VALUES RESULT NIL T)))))))
  269.  
  270. ;;; Excls and Atsigns...
  271.  
  272. (DEFUN BOXER-READER-EVAL-MACRO (LIST-SO-FAR STREAM)
  273.   (IF (EQ LIST-SO-FAR :TOPLEVEL)
  274.       (VALUES (LIST (MAKE-EVAL-IT-TOKEN (READ STREAM #\SPACE))) NIL T)
  275.       (VALUES (NCONC LIST-SO-FAR
  276.              (LIST (MAKE-EVAL-IT-TOKEN (READ STREAM #\SPACE))))
  277.           NIL T)))
  278.  
  279. (DEFUN BOXER-READER-UNBOX-MACRO (LIST-SO-FAR STREAM)
  280.   (IF (EQ LIST-SO-FAR :TOPLEVEL)
  281.       (VALUES (LIST (MAKE-UNBOX-TOKEN *UNBOX-MARKER* (READ STREAM #\SPACE))) NIL T)
  282.       (VALUES (NCONC LIST-SO-FAR
  283.              (LIST (MAKE-UNBOX-TOKEN *UNBOX-MARKER*
  284.                          (READ STREAM #\SPACE))))
  285.           NIL T)))
  286.  
  287. (COMMENT   ;;READER needs to save ALL text.  This may change with virtual copy....
  288. ;; empty out spaces looking for *STOP-ROW-CODE*, if we encounter an object call READ so we
  289. ;; can :TYI-A-BOX if we have to...
  290. (DEFUN BOXER-COMMENT-CHA-READER-MACRO (LIST-SO-FAR STREAM)
  291.   (DO ((INPUT (FUNCALL STREAM ':TYIPEEK) (FUNCALL STREAM ':TYIPEEK)))
  292.       ((OR (EQ INPUT *STOP-ROW-CODE*) (NULL INPUT))
  293.        (VALUES LIST-SO-FAR NIL T))
  294.     (IF (CHAR= INPUT *STRT-BOX-CODE*)
  295.     (READ STREAM *STOP-ROW-CODE*)
  296.     (FUNCALL STREAM ':TYI))))
  297. )
  298.  
  299. (DEFUN BOXER-RETURNED-VALUE-CHA-READER-MACRO (LIST-SO-FAR IGNORE)
  300.   (VALUES (APPEND LIST-SO-FAR (NCONS *VERTICAL-BAR-COMMENT*)) NIL T))
  301.  
  302. (DEFUN BOXER-COMMENT-CHA-READER-MACRO (LIST-SO-FAR IGNORE)
  303.   (VALUES (APPEND LIST-SO-FAR (NCONS *SEMI-COLON-COMMENT*)) NIL T))
  304.  
  305. (DEFUN BOXER-READ (STREAM EOF-OPTION)
  306.   (LET ((PACKAGE PKG-BOXER-USER-PACKAGE))
  307.     (BOXER-READ-P2 ;;convert atoms that look like flonums to flonums, since "." is turned off.
  308.       (LET ((READTABLE *BOXER-READTABLE*))
  309.     (READ STREAM EOF-OPTION)))))
  310.  
  311. (DEFUN BOXER-READ-P2 (EXP)
  312.   (IF (ATOM EXP)
  313.       (IF (SYMBOLP EXP)
  314.       (LET ((R (ERRSET (READ-FROM-STRING (GET-PNAME EXP)) NIL)))
  315.         (IF (NUMBERP (CAR R))
  316.         (CAR R)
  317.         EXP))
  318.       EXP)
  319.       (CONS (BOXER-READ-P2 (CAR EXP))
  320.         (BOXER-READ-P2 (CDR EXP)))))
  321.  
  322. (DEFUN NAMED-BOX-P (THING)
  323.   (AND (BOX? THING) (NAME-ROW? (TELL THING :NAME-ROW))))
  324.  
  325.  
  326.  
  327.  
  328. ;(defmethod (row :entries-for-pre-box)()
  329. ;  (let ((firstcut (tell self :uncopied-entries-for-pre-box)))
  330. ;    (mapcar #'(lambda (entry)(if (box? entry)(translate-box-to-pre-box entry) entry))
  331. ;        firstcut)))
  332.  
  333. (defmethod (row :entries-for-pre-box)()
  334.   (let* ((result  (pre-row-read (make-row-stream self) nil))
  335.      (result2 (totally-deblank result)))
  336.     (setq cached-entries result2)
  337.     (setq cached-elements (mapcar #'row-entry-element cached-entries))
  338.     result))
  339.  
  340. (defvar *boxer-pre-row-reader-on?* nil)
  341. (defvar *boxer-pre-row-build-reader-on?* nil)
  342.  
  343. (defun pre-row-read (row-stream eof-option &optional (build-reader? nil))
  344.   (let ((package pkg-boxer-user-package))
  345.     (boxer-read-p2
  346.       (let ((readtable *boxer-readtable*)(read-preserve-delimiters t)
  347.         (*boxer-pre-row-reader-on?* t)
  348.         (*boxer-pre-row-build-reader-on?* build-reader?))
  349.     (read row-stream eof-option)))))
  350.  
  351. (defmethod (row :entries-for-build-pre-box)()
  352.   (pre-row-read (make-row-stream self) nil t))
  353.  
  354.  
  355.  
  356.  
  357. ;(defun read-with-spaces (row-stream eof-option)
  358. ;  (tell row-stream :tyi)     ;to get opening paren out of the way
  359. ;  (prog ((result nil)(space-ctr 0)(next-cha nil))
  360. ;    (setq *boxer-pre-row-reader-on?* t)
  361. ;    (setq result (append result (read row-stream eof-option)))
  362. ;    (setq *boxer-pre-row-reader-on?* nil)(return result)))
  363. ;    tag1
  364. ;    (setq next-cha (tell row-stream :tyipeek))
  365. ;    (cond ((and (neq next-cha #\space)(not (= space-ctr 0)))
  366. ;           (setq result (append result (list `( ,space-ctr))))
  367. ;           (setq space-ctr 0)
  368. ;           (go tag1))
  369. ;          ((eq next-cha #\})
  370. ;           (tell row-stream :tyi)(setq result (append result eof-option))
  371. ;           (return result)))
  372. ;     tag2
  373. ;    (if (eq next-cha  #\space)
  374. ;        (progn (setq space-ctr (1+ space-ctr))
  375. ;           (tell row-stream :tyi)(go tag1)))
  376. ;    (setq result (append result (list (read row-stream eof-option))))
  377. ;    (go tag1)))
  378.  
  379. (DEFMETHOD (ROW :CACHE-READ-RESULT) ()
  380.   (SETQ CACHED-ITEMS    (BOXER-READ (MAKE-ROW-STREAM SELF) nil)
  381.     CACHED-ENTRIES  (PARSE-LIST-FOR-EVAL CACHED-ITEMS)
  382.     CACHED-ELEMENTS (MAPCAR #'ROW-ENTRY-ELEMENT CACHED-ENTRIES)
  383.     CACHED?         T))
  384.  
  385. (DEFMETHOD (ROW :ENTRIES) ()
  386.   (UNLESS CACHED? (TELL SELF :CACHE-READ-RESULT))
  387.   CACHED-ENTRIES)
  388.  
  389. (DEFMETHOD (ROW :ELEMENTS) ()
  390.   (UNLESS CACHED? (TELL SELF :CACHE-READ-RESULT))
  391.   CACHED-ELEMENTS)
  392.  
  393. (DEFMETHOD (ROW :ITEMS) ()
  394.   (UNLESS CACHED? (TELL SELF :CACHE-READ-RESULT))
  395.   CACHED-ITEMS)
  396.  
  397. (DEFMETHOD (ROW :EVROW) ()
  398.   (UNLESS CACHED? (TELL SELF :CACHE-READ-RESULT))
  399.   CACHED-ITEMS)
  400.  
  401. #+SYMBOLICS(COMPILER:MAKE-MESSAGE-OBSOLETE :EVROW "Use the :ITEMS message instead")
  402.  
  403. (DEFMETHOD (ROW :LABELS) ()
  404.   (MAPCAR #'ROW-ENTRY-LABEL (TELL SELF :ENTRIES)))
  405.  
  406. ;(DEFMETHOD (ROW :NAMES) ()
  407. ;  (MAPCAR #'ROW-ENTRY-NAME (TELL SELF :ENTRIES)))
  408.  
  409.  
  410. (DEFMETHOD (ROW :TEXT-STRING) ()
  411.   (LET ((STREAM (MAKE-ROW-STREAM SELF)))
  412.     (TYI STREAM)
  413.     (LET ((STRING (READLINE STREAM)))
  414.       (NSUBSTRING STRING 0 (1- (STRING-LENGTH STRING))))))
  415.  
  416. (DEFMETHOD (BOX :TEXT-STRING) ()
  417.   (LET ((ROWS (BOX-ROWS SELF)))
  418.     (DO ((ROWS ROWS (CDR ROWS))
  419.      (STUFF ""))
  420.     ((NULL ROWS) (SUBSTRING STUFF 1))
  421.       (SETQ STUFF (STRING-APPEND STUFF
  422.                  #\CR
  423.                  (TELL (CAR ROWS) :TEXT-STRING))))))
  424.  
  425. (DEFUN MAKE-BOX-FROM-STRING (STRING)
  426.   "make a box from a string.  carriage returns start new rows.  this is the inverse function
  427. to the :TEXT-STRING method of boxes. "
  428.   (MAKE-BOX
  429.     (LOOP WITH START = 0
  430.       FOR INDEX FROM 0 TO (1- (STRING-LENGTH STRING))
  431.       FOR CHA = (AREF STRING INDEX)
  432.       WHEN (OR (CHAR= CHA #\CR) (CHAR= CHA #\LINE))
  433.         COLLECT (NCONS (NSUBSTRING STRING START INDEX)) INTO ROWS
  434.       WHEN (OR (CHAR= CHA #\CR) (CHAR= CHA #\LINE))
  435.         DO (SETQ START (1+ INDEX))
  436.       FINALLY
  437.         (RETURN (APPEND ROWS (NCONS (NCONS (NSUBSTRING STRING START INDEX))))))))
  438.  
  439.  
  440. ;;;;MAKE-mumble functions
  441.  
  442. ;;Use these functions to make chas rows and boxes.
  443.  
  444. (DEFUN MAKE-ROW (STUFF &OPTIONAL (COPY? T))
  445.   (COND ((ROW? STUFF)
  446.      STUFF)
  447.     (T
  448.      (LET ((ROW-STREAM (MAKE-ROW-STREAM `(:ROW . ,STUFF)))
  449.            (NEW-ROW (MAKE-INITIALIZED-ROW)))
  450.        (TELL NEW-ROW :SET-CONTENTS-FROM-STREAM ROW-STREAM COPY?)
  451.        NEW-ROW))))
  452.  
  453. ;(DEFUN MAKE-NAME-AND-INPUT-ROW (STUFF &OPTIONAL (CACHED-NAME NIL))
  454. ;  (COND ((ROW? STUFF)
  455. ;     STUFF)
  456. ;    (T
  457. ;     (LET ((ROW-STREAM (MAKE-ROW-STREAM `(:ROW . ,STUFF)))
  458. ;           (NEW-ROW (MAKE-INSTANCE 'NAME-AND-INPUT-ROW ':CACHED-NAME CACHED-NAME)))
  459. ;       (TELL NEW-ROW :SET-CONTENTS-FROM-STREAM ROW-STREAM NIL)
  460. ;       NEW-ROW))))
  461.  
  462. (DEFUN MAKE-BOX (STUFF &OPTIONAL (TYPE ':DATA-BOX) NAME)
  463.   (COND ((BOX? STUFF)
  464.      (TELL STUFF :SET-TYPE TYPE)        ;Should it copy instead?  --Leigh.
  465.      (UNLESS (NULL NAME)
  466.        (TELL STUFF :SET-NAME (MAKE-NAME-ROW `(,NAME))))
  467.      STUFF)
  468.     (T
  469.      (LET ((ROWS (OR (MAPCAR 'MAKE-ROW STUFF) `(,(MAKE-ROW ()))))
  470.            (BOX (MAKE-INITIALIZED-BOX ':TYPE TYPE)))
  471.        (TELL BOX :SET-FIRST-INFERIOR-ROW (CAR ROWS))
  472.        (TELL (CAR ROWS) :SET-SUPERIOR-BOX BOX)
  473.        (DOLIST (ROW (CDR ROWS))
  474.          (TELL BOX :APPEND-ROW ROW))
  475.        (UNLESS (NULL NAME)
  476.          (TELL BOX :SET-NAME (MAKE-NAME-ROW `(,NAME))))
  477.        BOX))))
  478.  
  479. (defun make-row-from-pre-row (pre-row)
  480.   (let ((row-stream (make-row-stream `(:pre-row . ,pre-row)))
  481.     (new-row (make-initialized-row)))
  482.     (tell new-row :set-contents-from-stream row-stream t)
  483.     new-row))
  484.  
  485.  
  486. (DEFUN BOX-ROWS (BOX)
  487.   (TELL BOX :ROWS))
  488.  
  489. (DEFUN ROW-ELEMENTS (ROW)
  490.   (TELL ROW :ELEMENTS))
  491.  
  492. (DEFUN ROW-LABELS (ROW)
  493.   (TELL ROW :LABELS))
  494.  
  495. ;(DEFUN ROW-NAMES (ROW)
  496. ;  (TELL ROW :NAMES))
  497.  
  498. (DEFUN ROW-ENTRIES (ROW)
  499.   (TELL ROW :ENTRIES))
  500.  
  501.  
  502. ;;;boxtop utilities..
  503. ;
  504. ;(DEFMETHOD (NAME-AND-INPUT-ROW :CACHED-NAME) ()
  505. ;  CACHED-NAME)
  506. ;
  507. ;(DEFMETHOD (NAME-AND-INPUT-ROW :INSERT-CHA-AT-CHA-NO) (CHA CHA-NO)
  508. ;  (CHAS-ARRAY-INSERT-CHA CHAS-ARRAY CHA-NO (IF (BOX? CHA) CHA (DPB *FONT-NUMBER-FOR-NAMING*
  509. ;                                   %%BOXER-FONT-NO-FIELD
  510. ;                                   CHA)))
  511. ;  (WHEN (BOX? CHA)
  512. ;    (PUSH CHA BOXES)
  513. ;    (TELL CHA :SET-SUPERIOR-ROW SELF))
  514. ;  (TELL SELF :MODIFIED))
  515. ;
  516. ;(DEFMETHOD (NAME-AND-INPUT-ROW :UPDATE-BINDINGS) ()
  517. ;  (LET ((NEW-NAME (GET-BOX-NAME SELF))        
  518. ;    (ENVIRONMENT (TELL SUPERIOR-BOX :SUPERIOR-BOX)))
  519. ;    (WHEN (NEQ NEW-NAME CACHED-NAME)
  520. ;      (UNLESS (NULL CACHED-NAME)
  521. ;    (TELL ENVIRONMENT :REMOVE-STATIC-VARIABLE CACHED-NAME))
  522. ;      (SETQ CACHED-NAME NEW-NAME))
  523. ;    (UNLESS (AND (STRINGP NEW-NAME) (STRING-EQUAL NEW-NAME ""))
  524. ;      (TELL ENVIRONMENT :ADD-STATIC-VARIABLE-PAIR NEW-NAME SUPERIOR-BOX))))
  525.  
  526.  
  527.  
  528. ;;; Name Tab utilities
  529.  
  530. (DEFMETHOD (NAME-ROW :CACHED-NAME) ()
  531.   CACHED-NAME)
  532.  
  533. (DEFMETHOD (NAME-ROW :INSERT-CHA-AT-CHA-NO) (CHA CHA-NO)
  534.   "Gives the characters in the naming area a different font. "
  535.   (IF (BOX? CHA)
  536.       (FERROR "An attempt was made to insert the box, ~S, into the row ~S" CHA SELF)
  537.       (CHAS-ARRAY-INSERT-CHA CHAS-ARRAY CHA-NO (DPB *FONT-NUMBER-FOR-NAMING*
  538.                             %%BOXER-FONT-NO-FIELD
  539.                             CHA)))
  540.   (TELL SELF :MODIFIED))
  541.  
  542. (DEFMETHOD (NAME-ROW :INSERT-ROW-CHAS-AT-CHA-NO) (ROW CHA-NO)
  543.   (LET ((ROW-CHAS-ARRAY (TELL ROW :CHAS-ARRAY))
  544.     (NEW-BOXES (TELL ROW :BOXES-IN-ROW)))
  545.     (IF (NOT-NULL NEW-BOXES)
  546.     (FERROR "An attempt was made to insert the boxes, ~S, into the row ~S" NEW-BOXES SELF)
  547.     (CHAS-ARRAY-MOVE-CHAS ROW-CHAS-ARRAY 0
  548.                   CHAS-ARRAY CHA-NO
  549.                   (CHAS-ARRAY-ACTIVE-LENGTH ROW-CHAS-ARRAY)
  550.                   SELF)))
  551.   (TELL SELF :MODIFIED))
  552.  
  553. (DEFMETHOD (NAME-ROW :UPDATE-BINDINGS) (&OPTIONAL (FORCE-RENAME? NIL))
  554.   (LET ((NEW-NAME (GET-BOX-NAME SELF))        
  555.     (ENVIRONMENT (TELL SUPERIOR-BOX :SUPERIOR-BOX)))
  556.     (COND ((AND (OR FORCE-RENAME? (NEQ NEW-NAME CACHED-NAME)) (NOT (NULL NEW-NAME)))
  557.        ;; if the name has changed, then remove the old name from the environment
  558.        (UNLESS (OR (NULL CACHED-NAME)
  559.                (NEQ SUPERIOR-BOX
  560.                 (cdr (TELL ENVIRONMENT
  561.                   :LOOKUP-STATIC-VARIABLE-IN-BOX-ONLY CACHED-NAME))))
  562.          (TELL ENVIRONMENT :REMOVE-STATIC-VARIABLE CACHED-NAME))
  563.        (SETQ CACHED-NAME NEW-NAME)
  564.        (TELL ENVIRONMENT :ADD-STATIC-VARIABLE-PAIR NEW-NAME SUPERIOR-BOX))
  565.       ((NEQ NEW-NAME CACHED-NAME)
  566.        (UNLESS (OR (NULL CACHED-NAME)
  567.                (NEQ SUPERIOR-BOX
  568.                 (cdr (TELL ENVIRONMENT
  569.                   :LOOKUP-STATIC-VARIABLE-IN-BOX-ONLY CACHED-NAME))))
  570.          (TELL ENVIRONMENT :REMOVE-STATIC-VARIABLE CACHED-NAME))
  571.        (SETQ CACHED-NAME NEW-NAME)))))
  572.  
  573. ;;;;COPYing
  574.  
  575. (DEFVAR .LINK-TARGET-ALIST. NIL
  576.   "An association list of ported-to boxes and their copies. ")
  577.  
  578. (DEFVAR .PORT-COPY-LIST. NIL
  579.   "A list of port copies which may want to have their destination changed at the end of a
  580. higher level copy operation. ")
  581.  
  582. (DEFUN COPY-TOP-LEVEL-BOX (BOX)
  583.     (LET ((RETURN-BOX (COPY-BOX BOX NIL)))
  584.       (DOLIST (PORT .PORT-COPY-LIST.)
  585.     (LET ((TARGET-PAIR (ASSQ (TELL PORT :PORTS) .LINK-TARGET-ALIST.)))
  586.       (WHEN (NOT-NULL TARGET-PAIR)
  587.         (TELL PORT :SET-PORT-TO-BOX (CDR TARGET-PAIR)))))
  588.       (SETQ .LINK-TARGET-ALIST. NIL
  589.         .PORT-COPY-LIST.    NIL)
  590.       RETURN-BOX))
  591.  
  592. (DEFUN COPY-BOX (BOX &OPTIONAL (WITH-NAME? T))
  593.   (LET ((NEW-BOX (TELL BOX :COPY)))
  594.     (WHEN (NULL WITH-NAME?))
  595.     (TELL NEW-BOX :SET-NAME NIL)
  596.     NEW-BOX))
  597.  
  598. (DEFUN COPY-ROW (ROW)
  599.   (TELL ROW :COPY))
  600.  
  601. (DEFMETHOD (BOX :COPY) ()
  602.   (LET ((NEW-BOX (MAKE-INITIALIZED-BOX))
  603.     (BOX-STREAM (MAKE-BOX-STREAM SELF)))
  604.     (TELL NEW-BOX :SET-CONTENTS-FROM-STREAM BOX-STREAM T)
  605.     (unless (null local-library)
  606.       (let ((new-ll (tell local-library :copy)))    
  607.     (tell new-box :set-local-library new-ll)
  608.     (tell new-ll :export-all-variables)
  609.     (tell new-box :add-static-variable-pair *exporting-box-marker* new-ll)))
  610.     (WHEN (NOT-NULL PORTS)
  611.       (PUSH (CONS SELF NEW-BOX) .LINK-TARGET-ALIST.))
  612.     NEW-BOX))
  613.  
  614. (DEFMETHOD (PORT-BOX :COPY) ()
  615.   (LET ((NEW-BOX (MAKE-INITIALIZED-BOX)))
  616.     (TELL NEW-BOX :SET-TYPE (TELL SELF :TYPE))
  617.     (TELL NEW-BOX :SET-DISPLAY-STYLE-LIST DISPLAY-STYLE-LIST)
  618.     (TELL NEW-BOX :SET-PORT-TO-BOX PORTS)
  619.     (unless (null (tell self :name-row))
  620.       (tell new-box :set-name (make-name-row `(,(tell self :name)))))
  621.     (LET ((TARGET-PAIR (ASSQ PORTS .LINK-TARGET-ALIST.)))
  622.       (IF (NULL TARGET-PAIR)
  623.       (PUSH NEW-BOX .PORT-COPY-LIST.)
  624.       (TELL NEW-BOX :SET-PORT-TO-BOX (CDR TARGET-PAIR))))
  625.     NEW-BOX))
  626.  
  627. (DEFMETHOD (ROW :COPY) ()
  628.   (LET ((NEW-ROW (MAKE-INITIALIZED-ROW))
  629.     (ROW-STREAM (MAKE-ROW-STREAM SELF)))
  630.     (TELL NEW-ROW :SET-CONTENTS-FROM-STREAM ROW-STREAM T)
  631.     NEW-ROW))
  632.  
  633.  
  634.  
  635. ;;;;BOX-EQUAL
  636. (DEFUN BOX-EQUAL (BOX1 BOX2)
  637.   (TELL BOX1 :EQUAL BOX2))
  638.  
  639. (DEFUN ROW-EQUAL (ROW1 ROW2)
  640.   (TELL ROW1 :EQUAL ROW2))
  641.  
  642. (DEFMETHOD (BOX :EQUAL) (BOX)
  643.   (LET ((MY-LENGTH-IN-ROWS (TELL SELF :LENGTH-IN-ROWS))
  644.     (HE-LENGTH-IN-ROWS (TELL BOX :LENGTH-IN-ROWS)))
  645.     (COND (( MY-LENGTH-IN-ROWS HE-LENGTH-IN-ROWS) NIL)
  646.       (T
  647.        (DO* ((ROW-NO 0 (+ ROW-NO 1))
  648.          (MY-ROW (TELL SELF :ROW-AT-ROW-NO ROW-NO) (TELL SELF :ROW-AT-ROW-NO ROW-NO))
  649.          (HE-ROW (TELL BOX :ROW-AT-ROW-NO ROW-NO) (TELL BOX :ROW-AT-ROW-NO ROW-NO)))
  650.         ((>= ROW-NO MY-LENGTH-IN-ROWS) T)
  651.          (OR (TELL MY-ROW :EQUAL HE-ROW)
  652.          (RETURN NIL)))))))
  653.  
  654. (DEFMETHOD (ROW :EQUAL) (ROW)
  655.   (LET ((MY-LENGTH-IN-CHAS (TELL SELF :LENGTH-IN-CHAS))
  656.     (HE-LENGTH-IN-CHAS (TELL ROW :LENGTH-IN-CHAS)))
  657.     (COND (( MY-LENGTH-IN-CHAS HE-LENGTH-IN-CHAS) NIL)
  658.       (T
  659.        (DO* ((CHA-NO 0 (+ CHA-NO 1))
  660.          (MY-CHA (TELL SELF :CHA-AT-CHA-NO CHA-NO) (TELL SELF :CHA-AT-CHA-NO CHA-NO))
  661.          (HE-CHA (TELL ROW :CHA-AT-CHA-NO CHA-NO) (TELL ROW :CHA-AT-CHA-NO CHA-NO)))
  662.         ((>= CHA-NO MY-LENGTH-IN-CHAS) T)
  663.          (COND ((AND (BOX? MY-CHA) (BOX? HE-CHA))
  664.             (IF (NOT (TELL MY-CHA :EQUAL HE-CHA))
  665.             (RETURN NIL)))
  666.            ((EQ (CHA-CODE MY-CHA) (CHA-CODE HE-CHA))
  667.             T)
  668.            (T (RETURN NIL))))))))
  669.  
  670.  
  671.  
  672. (COMMENT
  673. ;The boxer PRINT function has been removed.  Use returned values or something.
  674. ;We'll decide what to do sometime later.
  675.  
  676. (DEFUN BOXER-PRINT (STUFF PLACE)
  677.   (FERROR "PRINT is not implemented these days.")
  678.   (COND ((BOX? STUFF)
  679.      (BOXER-PRINT-BOX STUFF PLACE))
  680.     ((ROW? STUFF)
  681.      (BOXER-PRINT-ROW STUFF PLACE))
  682.     ((CHA? STUFF)
  683.      (BOXER-PRINT-CHA STUFF PLACE))
  684.     ((STRINGP STUFF)
  685.      (BOXER-PRINT-STRING STUFF PLACE))
  686.     ((SYMBOLP STUFF)
  687.      (BOXER-PRINT-SYMBOL STUFF PLACE))
  688.     (T
  689.      (BOXER-PRINT-RANDOM-THING STUFF PLACE))))
  690.  
  691. (DEFUN BOXER-PRINT-BOX (BOX PLACE)
  692.   (LET ((COPY (COPY-BOX BOX)))
  693.     (COND ((EQ PLACE ':CURSOR)
  694.        (INSERT-CHA *point* COPY))
  695.       ((BOX? PLACE)
  696.        (IF (NULL (WTELL PLACE :LAST-ROW))
  697.          (TELL (MAKE-INITIALIZED-ROW) :APPEND PLACE))
  698.        (TELL COPY :APPEND (TELL PLACE :LAST-ROW))))))
  699.  
  700. (DEFUN BOXER-PRINT-ROW (ROW PLACE)
  701.   (LET ((COPY (COPY-ROW ROW)))
  702.     (COND ((EQ PLACE ':CURSOR)
  703.        (INSERT-ROW *point* COPY))
  704.       ((BOX? PLACE)
  705.        (TELL COPY :APPEND-ROW PLACE))
  706.       (T (FERROR "Can't print a row to ~S" place)))))
  707.  
  708. (DEFUN BOXER-PRINT-CHA (CHA PLACE)
  709.   (LET ((COPY (COPY-CHA CHA)))
  710.     (COND ((EQ PLACE ':CURSOR)
  711.        (INSERT-CHA *point* COPY))
  712.       ((BOX? PLACE)
  713.        (IF (NULL (TELL PLACE :LAST-ROW))
  714.          (TELL (MAKE-INITIALIZED-ROW) :APPEND PLACE))
  715.        (TELL COPY :APPEND (TELL PLACE :LAST-ROW))))))
  716.  
  717. (DEFUN BOXER-PRINT-STRING (STRING PLACE)
  718.   (WITH-INPUT-FROM-STRING (INSTREAM (MAKE-STRING-WITH-FILL-POINTER STRING))
  719.     (DO ((INPUT (TELL INSTREAM :TYI) (TELL INSTREAM :TYI)))
  720.     ((NULL INPUT))
  721.       (BOXER-PRINT-CODE INPUT PLACE))))
  722.  
  723. (DEFUN BOXER-PRINT-SYMBOL (SYMBOL PLACE)
  724.   (BOXER-PRINT-STRING (STRING SYMBOL) PLACE))
  725.  
  726. (DEFUN BOXER-PRINT-CODE (CODE PLACE)
  727.   (COND ((EQ PLACE ':CURSOR)
  728.      (IF (= CODE #\RETURN)
  729.          (INSERT-RETURN *point*)
  730.          (INSERT-CHA *point* (MAKE-CHA CODE))))
  731.     ((BOX? PLACE)
  732.      (IF (NULL (TELL PLACE :LAST-ROW))
  733.          (TELL (MAKE-INITIALIZED-ROW) :APPEND PLACE))
  734.      (IF (= CODE #\RETURN)
  735.          (TELL (MAKE-INITIALIZED-ROW) :APPEND PLACE)
  736.          (TELL (MAKE-CHA CODE) :APPEND (TELL PLACE :LAST-ROW))))))
  737.  
  738. (DEFUN BOXER-PRINT-RANDOM-THING (RANDOM-THING PLACE)
  739.   (BOXER-PRINT-STRING (FORMAT NIL "~s" RANDOM-THING) PLACE))
  740.  
  741. (DEFUN MAKE-STRING-WITH-FILL-POINTER (STUFF)
  742.   (LET ((STRING (MAKE-ARRAY '(8.) ':TYPE 'ART-STRING ':LEADER-LIST '(0))))
  743.     (COND ((STRINGP STUFF)
  744.        (STRING-NCONC STRING STUFF))
  745.       (T
  746.        (FORMAT STRING "~s" STUFF)))
  747.     STRING))
  748. );END OF COMMENTED-OUT PRINT FUNCTION
  749.